home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 12 / Cream of the Crop 12 (Part II) / Cream of the Crop 12 (Part II).iso / BBS / EZY120_1.ZIP / STRUCT.ARJ / PASLIB.ARJ / FOSSIL.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-03-09  |  12.9 KB  |  522 lines
  1. (* *************************************************************************
  2.  *                                                                         *
  3.  *       Program:  Fossil Routines                                         *
  4.  *       Language: Borland Pascal V7.0                                     *
  5.  *       Revision: V1.0 13/1/95                                            *
  6.  *                                                                         *
  7.  *       Copyright (C) Peter Davies 1995.  All Rights Reserved             *
  8.  *                                                                         *
  9.  *       Conditions of use                                                 *
  10.  *          May be freely used and Modified.                               *
  11.  *          Modified versions can not be distributed.                      *
  12.  *          Any damage caused by this software, is at the users risk.      *
  13.  *          The author takes no responsibility whatsover for the damage    *
  14.  *          this software may, or may not cause                            *
  15.  *                                                                         *
  16.  ************************************************************************* *)
  17.  
  18.  
  19. unit fossil;
  20.  
  21. interface
  22.  
  23. uses objects, Dos, Strings;
  24.  
  25. const
  26.    ExtendedFossil : Boolean = False;
  27.    CarrierValue   : Byte    = $80;
  28.    CR                       = #$0D + #$0A;        (* Carriage Return *)
  29.    BS                       = #$08 + #$20 + #$08; (* Backspace *)
  30.    TimeOut        : Word    = 120;
  31.  
  32. type
  33.    FossilInfoType = record
  34.       InfoSize     : word;
  35.       CurrFossil   : byte;            (* Fossil version number  *)
  36.       CurrRev      : byte;            (*        revision number *)
  37.       IDString     : PChar;           (* Fossils ID string      *)
  38.       IBSize       : word;            (* Input buffer size      *)
  39.       IBFree       : word;            (* free space in inbuf    *)
  40.       OBSize       : word;            (* Output buffer size     *)
  41.       OBFree       : word;            (* free space in outbuf   *)
  42.       ScreenWidth  : byte;
  43.       ScreenHeight : byte;
  44.       Baud         : byte;            (* Baud mask, see Proc SetBaud *)
  45.    end;
  46.  
  47.    PFossil = ^TFossil;
  48.    TFossil = object(TObject)
  49.     Private
  50.       ComPort          : word;     (* 0 = Com1, 1 = Com2 *)
  51.       FossilActive     : boolean;
  52.       BaudRate         : longint;
  53.       FossilInfo       : ^FossilInfoType;
  54.       procedure        GetFossilInfo;
  55.  
  56.     Public
  57.       constructor      Init(NewComPort : word);     (* 1 = Com1, 2 = Com2 *)
  58.       destructor       Done; virtual;
  59.       function         CarrierDetected   : boolean;
  60.       function         CharAvailInOutputBuffer : boolean;
  61.       procedure        ClearInputBuffer;
  62.       procedure        ClearOutputBuffer;
  63.       procedure        FlushOutputBuffer;
  64.       function         FreeSpaceInInputBuffer  : word;
  65.       function         FreeSpaceInOutputBuffer : word;
  66.       function         GetBaudRate       : longint;
  67.       procedure        GetBlock(var DataBlock;MaxBlockLen : word;var BlockLenRead : word);
  68.       function         GetChar           : char;
  69.       function         GetComPort        : word;
  70.       function         GetFossilActive   : boolean;
  71.       function         GetFossilIDString : string;
  72.       function         GetFossilRevision : byte;
  73.       function         GetFossilVersion  : byte;
  74.       procedure        GiveTimeSlice;    virtual;
  75.       procedure        HardwareFlowControl;
  76.       function         InputBufferEmpty   : boolean;
  77.       procedure        LowerDtr;
  78.       function         OutputBufferEmpty  : boolean;
  79.       procedure        PutBlock(var DataBlock;BlockLen : word;var BlockLenWritten : word);
  80.       procedure        PutBlockCD(var DataBlock;BlockLen : word);
  81.       procedure        PutChar(X : char);
  82.       procedure        PutCharCD(X : char);
  83.       procedure        PutStringCD(S : String);
  84.       procedure        RaiseDtr;
  85.       procedure        SetBaud(NewBaudRate : longint);
  86.       procedure        SetTimerSecs(Secs : Longint);
  87.       function         SizeOfInputBuffer  : word;
  88.       function         SizeOfOutputBuffer : word;
  89.       function         TimerExpired : boolean;
  90.    end;
  91.  
  92. implementation
  93.  
  94. constructor TFossil.Init(NewComPort : Word);
  95.  
  96. var
  97.    Regs : Registers;
  98.  
  99. begin
  100.    ComPort := NewComPort - 1;
  101.    Regs.ah := $04; (* Init Fossil *)
  102.    Regs.dx := ComPort;
  103.    Regs.bx := $00;
  104.    Intr($14,Regs);
  105.    FossilActive := (Regs.AX = $1954);
  106.    if FossilActive and (not ((Regs.bh >= 5) and (Regs.bl >= $1b))) then begin
  107.       FossilActive := False;
  108.       Regs.dx := ComPort; (* DeInit Fossil *)
  109.       Regs.ah := $05;
  110.       intr($14,Regs);
  111.    end;
  112.    if FossilActive then begin
  113.       new(FossilInfo);
  114.       GetFossilInfo;
  115.    end;
  116. end;
  117.  
  118. destructor TFossil.Done;  (* kill fossil *)
  119.  
  120. var
  121.    Regs : Registers;
  122.  
  123. begin
  124.    if FossilActive then begin
  125.       dispose(FossilInfo);
  126.       Regs.AH := $05;
  127.       Regs.DX := ComPort;
  128.       Intr($14,Regs);
  129.       FossilActive := False;
  130.    end;
  131.    inherited Done;
  132. end;
  133.  
  134. function TFossil.CarrierDetected : boolean;
  135.  
  136. var
  137.    Regs : Registers;
  138.  
  139. begin
  140.    Regs.ah := $03;
  141.    Regs.dx := ComPort;
  142.    intr($14,Regs);
  143.    CarrierDetected := ((Regs.al and CarrierValue) > 0)
  144. end;
  145.  
  146. function TFossil.CharAvailInOutputBuffer : boolean;
  147.  
  148. var
  149.    Regs : Registers;
  150.  
  151. begin
  152.    Regs.ah := $03;
  153.    Regs.dx := ComPort;
  154.    intr($14,Regs);
  155.    CharAvailInOutputBuffer := ((Regs.ah and $20) > 0); (* room in output buffer? *)
  156. end;
  157.  
  158. procedure TFossil.ClearInputBuffer;
  159.  
  160. var
  161.    Regs : Registers;
  162.  
  163. begin
  164.    Regs.ah := $0A;
  165.    Regs.dx := ComPort;
  166.    intr($14,Regs);
  167. end;
  168.  
  169. procedure TFossil.ClearOutputBuffer;
  170.  
  171. var
  172.    Regs : Registers;
  173.  
  174. begin
  175.    Regs.ah := $09;
  176.    Regs.dx := ComPort;
  177.    intr($14,Regs);
  178. end;
  179.  
  180. procedure TFossil.FlushOutputBuffer;
  181.  
  182. begin
  183.    SetTimerSecs(TimeOut);
  184.    while (not OutputBufferEmpty) and CarrierDetected and (not TimerExpired) do
  185.       GiveTimeSlice;
  186. end;
  187.  
  188. function  TFossil.FreeSpaceInInputBuffer  : word;
  189.  
  190. begin
  191.    GetFossilInfo;
  192.    FreeSpaceInInputBuffer := FossilInfo^.IBFree;
  193. end;
  194.  
  195. function  TFossil.FreeSpaceInOutputBuffer : word;
  196.  
  197. begin
  198.    GetFossilInfo;
  199.    FreeSpaceInOutputBuffer := FossilInfo^.OBFree;
  200. end;
  201.  
  202. function TFossil.GetBaudRate : Longint;
  203.  
  204. begin
  205.    GetBaudRate     := BaudRate;
  206. end;
  207.  
  208. function TFossil.GetComPort : word;
  209.  
  210. begin
  211.    GetComPort      := ComPort + 1;
  212. end;
  213.  
  214. procedure TFossil.GetBlock(var DataBlock;MaxBlockLen : word;var BlockLenRead : word);
  215.  
  216. var
  217.    Regs : Registers;
  218.  
  219. begin
  220.    Regs.ah := $18;
  221.    Regs.cx := MaxBlockLen;
  222.    Regs.es := seg(DataBlock);
  223.    Regs.di := ofs(DataBlock);
  224.    Regs.dx := ComPort;
  225.    intr($14,Regs);
  226.    BlockLenRead := Regs.ax;
  227. end;
  228.  
  229. function  TFossil.GetChar : char;
  230.  
  231. var
  232.    Regs : Registers;
  233.  
  234. begin
  235.    Regs.ah := $02;
  236.    Regs.dx := ComPort;
  237.    intr($14,Regs);
  238.    GetChar := chr(Regs.al);
  239. end;
  240.  
  241. function TFossil.GetFossilActive : boolean;
  242.  
  243. begin
  244.    GetFossilActive := FossilActive;
  245. end;
  246.  
  247. procedure TFossil.GetFossilInfo;
  248.  
  249. var
  250.    Regs : Registers;
  251.  
  252. begin
  253.    Regs.ah := $1b;
  254.    Regs.cx := sizeof(FossilInfoType);
  255.    Regs.dx := ComPort;
  256.    Regs.es := seg(FossilInfo^);
  257.    Regs.di := ofs(FossilInfo^);
  258.    intr($14,Regs);
  259.    (*
  260.  
  261.    if (FossilInfo^.InfoSize <> sizeof(FossilInfoType)) then begin
  262.       ???? What to do ????
  263.    end;
  264.  
  265.    *)
  266. end;
  267.  
  268. function TFossil.GetFossilIDString : String;
  269.  
  270. begin
  271.    GetFossilIDString := strpas(FossilInfo^.IDString);
  272. end;
  273.  
  274. function TFossil.GetFossilRevision : byte;
  275.  
  276. begin
  277.    GetFossilRevision := FossilInfo^.CurrRev;
  278. end;
  279.  
  280. function TFossil.GetFossilVersion  : byte;
  281.  
  282. begin
  283.    GetFossilVersion  := FossilInfo^.CurrFossil;
  284. end;
  285.  
  286. procedure TFossil.GiveTimeSlice;
  287.  
  288. begin
  289.    (* Override this function to give away time slices *)
  290. end;
  291.  
  292. procedure TFossil.HardwareFlowControl;
  293.  
  294. var
  295.    Regs : Registers;
  296.  
  297. begin
  298.    Regs.ah := $0F;
  299.    Regs.dx := ComPort;
  300.    Regs.al := $02;
  301.    intr($14,Regs);
  302. end;
  303.  
  304. function TFossil.InputBufferEmpty : boolean;
  305.  
  306. var
  307.    Regs : Registers;
  308.  
  309. begin
  310.    Regs.ah := $03;
  311.    Regs.dx := ComPort;
  312.    intr($14,Regs);
  313.    InputBufferEmpty := ((Regs.ah and $01) = 0);
  314. end;
  315.  
  316. procedure TFossil.LowerDTR;
  317.  
  318. var
  319.    Regs : Registers;
  320.  
  321. begin
  322.    Regs.ah := $06;
  323.    Regs.dx := ComPort;
  324.    Regs.al := $00;
  325.    intr($14,Regs);
  326. end;
  327.  
  328. function TFossil.OutputBufferEmpty : boolean;
  329.  
  330. var
  331.    Regs : Registers;
  332.  
  333. begin
  334.    Regs.ah := $03;
  335.    Regs.dx := ComPort;
  336.    intr($14,Regs);
  337.    OutputBufferEmpty := ((Regs.ah and $40) > 0);
  338. end;
  339.  
  340. procedure TFossil.PutBlock(var DataBlock;BlockLen : word;var BlockLenWritten : word);
  341.  
  342. var
  343.    Regs : Registers;
  344.  
  345. begin
  346.    Regs.ah := $19;
  347.    Regs.cx := BlockLen;
  348.    Regs.es := seg(DataBlock);
  349.    Regs.di := ofs(DataBlock);
  350.    Regs.dx := ComPort;
  351.    intr($14,Regs);
  352.    BlockLenWritten := Regs.ax;
  353. end;
  354.  
  355. procedure TFossil.PutBlockCD(var DataBlock;BlockLen : word);
  356.  
  357. type
  358.    DataBlockType = array[0..65530] of char;
  359.  
  360. var
  361.    BytesWritten      : Word;
  362.    TotalBytesWritten : Word;
  363.    DataBlockBytes    : DataBlockType absolute DataBlock;
  364.  
  365. begin
  366.    SetTimerSecs(TimeOut);
  367.    TotalBytesWritten := 0;
  368.    while (TotalBytesWritten < BlockLen) and CarrierDetected and (not TimerExpired) do begin
  369.       PutBlock(DataBlockBytes[TotalBytesWritten],BlockLen-TotalBytesWritten,BytesWritten);
  370.       inc(TotalBytesWritten,BytesWritten);
  371.       if (TotalBytesWritten < BlockLen) then
  372.          GiveTimeSlice;
  373.    end;
  374. end;
  375.  
  376. procedure TFossil.PutChar(X : char);
  377.  
  378. var
  379.    Regs : Registers;
  380.  
  381. begin
  382.    Regs.ah := $01;
  383.    Regs.dx := ComPort;
  384.    Regs.al := ord(X);
  385.    intr($14,Regs);
  386. end;
  387.  
  388. procedure TFossil.PutCharCD(X : char);
  389.  
  390. label
  391.    WaitChar;
  392.  
  393. var
  394.    Regs : Registers;
  395.  
  396. begin
  397.    SetTimerSecs(TimeOut);
  398.    WaitChar :
  399.       Regs.ah := $03;
  400.       Regs.dx := ComPort;
  401.       intr($14,Regs);
  402.       if ((Regs.al and CarrierValue) > 0) then begin (* Carrier Detected *)
  403.          if ((Regs.ah and $20) > 0) then begin (* Space in Output Buffer *)
  404.             Regs.ah := $01;
  405.             Regs.dx := ComPort;
  406.             Regs.al := ord(X);
  407.             intr($14,Regs);
  408.          end else begin      (* No Space in Output Buffer *)
  409.             if Not TimerExpired then begin
  410.                GiveTimeSlice;
  411.                goto WaitChar;
  412.             end;
  413.          end;
  414.       end else
  415.          ClearOutputBuffer; (* No Carrier *)
  416. end;
  417.  
  418. procedure  TFossil.PutStringCD(S : String);
  419.  
  420. begin
  421.    PutBlockCD(S[1],length(S));
  422. end;
  423.  
  424. procedure  TFossil.RaiseDtr;
  425.  
  426. var
  427.    Regs : Registers;
  428.  
  429. begin
  430.    Regs.ah := $06;
  431.    Regs.dx := ComPort;
  432.    Regs.al := $01;
  433.    intr($14,Regs);
  434. end;
  435.  
  436. procedure  TFossil.SetBaud(NewBaudRate : longint);
  437.  
  438. var
  439.    Regs : Registers;
  440.  
  441. begin
  442.    if FossilActive then begin
  443.       BaudRate := NewBaudRate;
  444.       if ExtendedFossil then begin
  445.          Regs.AH := $1E;
  446.          Regs.AL := $00;
  447.          Regs.BH := $00;
  448.          Regs.BL := $00;
  449.          Regs.CH := $00;
  450.          if (BaudRate = 300) then
  451.             Regs.CL := $03
  452.          else if (BaudRate = 1200) then
  453.             Regs.CL := $04
  454.          else if (BaudRate = 2400) then
  455.             Regs.CL := $05
  456.          else if (BaudRate = 4800) then
  457.             Regs.CL := $06
  458.          else if (BaudRate = 9600) then
  459.             Regs.CL := $07
  460.          else if (BaudRate = 19200) then
  461.             Regs.CL := $08
  462.          else if (BaudRate = 28800) then
  463.             Regs.CL := $80
  464.          else if (BaudRate = 38400) then
  465.             Regs.CL := $81
  466.          else if (BaudRate = 57600) then
  467.             Regs.CL := $82
  468.          else if (BaudRate = 76800) then
  469.             Regs.CL := $83
  470.          else if (BaudRate = 115200) then
  471.             Regs.CL := $84;
  472.          Regs.DX := ComPort;
  473.          Intr($14,Regs);
  474.       end else begin
  475.          Regs.AH := $00;
  476.          Regs.DX := ComPort;
  477.          regs.AL := $00;
  478.          if (BaudRate = 9600) then
  479.             Regs.Al := Regs.Al or $E0
  480.          else if (BaudRate = 300) then
  481.             Regs.Al := Regs.Al or $40
  482.          else if (BaudRate = 1200) then
  483.             Regs.Al := Regs.Al or $80
  484.          else if (BaudRate = 4800) then
  485.             Regs.Al := Regs.Al or $C0
  486.          else if (BaudRate = 38400) then
  487.             Regs.Al := Regs.Al or $20
  488.          else if (BaudRate = 2400) then
  489.             Regs.Al := Regs.Al or $A0;
  490.          Regs.Al := Regs.Al or $3;        (* Set N,8,1 *)
  491.          Intr($14,Regs);
  492.       end;
  493.    end;
  494. end;
  495.  
  496. procedure TFossil.SetTimerSecs(Secs : Longint);
  497.  
  498. begin
  499.    (* Override this procedure with your own timer functions *)
  500. end;
  501.  
  502. function  TFossil.SizeOfInputBuffer : word;
  503.  
  504. begin
  505.    SizeOfInputBuffer := FossilInfo^.IBSize;
  506. end;
  507.  
  508. function  TFossil.SizeOfOutputBuffer : word;
  509.  
  510. begin
  511.    SizeOfOutputBuffer := FossilInfo^.OBSize;
  512. end;
  513.  
  514. function  TFossil.TimerExpired : boolean;
  515.  
  516. begin
  517.    (* Override this function with your own timer functions *)
  518.    TimerExpired := False;
  519. end;
  520.  
  521. end.
  522.